home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / rts / bummed-jar-defrecord.scm < prev    next >
Text File  |  1995-10-13  |  2KB  |  70 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4. ; Same as jar-defrecord.scm, but field access is "optimized" in a
  5. ; brutally unmodular way.  The accessors and modifiers are easily
  6. ; recognized as inlinable because instead of being produced by the
  7. ; usual record-accessor and record-modifier combinators, they're
  8. ; defined directly as procedures that do record-ref and record-set!
  9. ; with constant indexes.  There is no check to make sure that the
  10. ; record is a record of the correct type.
  11.  
  12. ; Since the record types are not checked at run time, we use LOOPHOLE
  13. ; to at least try to get a little bit of compile-time checking.
  14.  
  15. (define-syntax define-record-type    ;same as in jar-defrecord.scm
  16.   (syntax-rules ()
  17.     ((define-record-type ?id ?type
  18.        (?constructor ?arg ...)
  19.        (?field . ?field-stuff)
  20.        ...)
  21.      (begin (define ?type (make-record-type '?id '(?field ...)))
  22.         (define-constructor ?constructor ?type (?arg :value) ...)
  23.         (define-accessors ?type (?field . ?field-stuff) ...)))
  24.     ((define-record-type ?id ?type
  25.        (?constructor ?arg ...)
  26.        ?pred
  27.        ?more ...)
  28.      (begin (define-record-type ?id ?type
  29.           (?constructor ?arg ...)
  30.           ?more ...)
  31.         (define ?pred (record-predicate ?type))))))
  32.  
  33. (define-syntax define-constructor
  34.   (syntax-rules ()
  35.     ((define-constructor ?constructor ?type (?arg ?arg-type) ...)
  36.      (define ?constructor
  37.        (loophole (proc (?arg-type ...) ?type)
  38.          (record-constructor ?type '(?arg ...)))))))
  39.  
  40. (define-syntax define-accessors
  41.   (lambda (e r c)
  42.     (let ((%define-accessor (r 'define-accessor))
  43.       (%begin (r 'begin))
  44.       (type (cadr e))
  45.       (field-specs (cddr e)))
  46.       (do ((i 1 (+ i 1))
  47.        (field-specs field-specs (cdr field-specs))
  48.        (ds '()
  49.            (cons `(,%define-accessor ,type ,i ,@(cdar field-specs))
  50.              ds)))
  51.       ((null? field-specs)
  52.        `(,%begin ,@ds)))))
  53.   (define-accessor begin))
  54.  
  55. (define-syntax define-accessor
  56.   (syntax-rules ()
  57.     ((define-accessor ?type ?index ?accessor)
  58.      (define ?accessor
  59.        (loophole (proc (?type) :value)
  60.          (lambda (r)
  61.            (record-ref (loophole :record r) ?index)))))
  62.     ((define-accessor ?type ?index ?accessor ?modifier)
  63.      (begin (define-accessor ?type ?index ?accessor)
  64.         (define ?modifier
  65.           (loophole (proc (?type :value) :unspecific)
  66.             (lambda (r new)
  67.               (record-set! (loophole :record r) ?index new))))))
  68.     ((define-accessor ?type ?index)
  69.      (begin))))
  70.